{-# LANGUAGE MultiParamTypeClasses #-}

-- |circular and enumerable
module Cyc where

import Utility (
--      list
      enumDiff
    , enumInds
    , cleanMaybes
    , maybeize
    , monotonic
    , index
--    , cumsum
--    , filtByKey
--    , interleave
--    , zipInto
--    , zipMap
    , numElems
    , between
    )

import Data.List (minimumBy,nub)
import Data.Function (on)

default ()

-- |Enum that wraps around
--
--  no minimum definition (completely derivable -- but haskell can't autoderive custom classes?)
--
--  days, months, hours, mins, and secs should use this.
class (Eq a, Bounded a, Enum a) => Cyc a where

    -- |succ with wraparound
    succCyc :: a
            -> a
    succCyc x | x == maxBound = minBound
              | otherwise     = succ x

    -- |pred with wraparound
    predCyc :: a
            -> a
    predCyc x | x == minBound = maxBound
              | otherwise     = pred x

    -- |shortest step distance from 1st to 2nd arg (your closest exit may be behind you)
    shortest :: a
             -> a
             -> Int
    shortest x y | (abs pos) <= (biggest `div` 2) = pos
                 | otherwise                      = pos - (signum pos) * (biggest + 1)
                 where pos     = enumDiff x y
                       biggest = fromEnum (maxBound `asTypeOf` x)

    -- |list of n steps starting with arg (includes arg, so length of result is (abs n)+1)
    path :: Int
         -> a
         -> [a]
    path n = take (1 + (abs n)) . pathFrom (n > 0)

    -- |list of steps in range specified by first two args
    pathRange :: Int
              -> Int
              -> a
              -> [a]
    pathRange i j x = path (j - i) (travel i x)

{- how define postfix unary?
--    infixl 9 ...
    (...) :: a -> [a]
    x ... = pathFrom True x
-}

    -- |infinite list of steps starting with arg
    pathFrom :: Bool -- ^'True' for ascending, 'False' for descending
             -> a
             -> [a]
    pathFrom b = iterate $ if b then succCyc else predCyc

    -- |list of steps in path from 1st to 2nd arg (inclusive)
    pathFromTo :: a
               -> a
               -> Maybe Bool -- ^'Just' 'True' for ascending, 'Just' 'False' for descending, 'Nothing' for shortest
               -> [a]
    pathFromTo x y Nothing  = path (shortest x y) x
    pathFromTo x y (Just b) = (takeWhile (/= y) (pathFrom b x)) ++ [y]

    -- |transform arg by traveling n steps (n may be negative)
    travel :: Int
           -> a
           -> a
    travel = (last .) . path

{-
task:

allow the user to define a cyclic enumerated set of elements, each with an associated metric which denotes the ascending (not necessarily monotonic) distance from it to the following element.  provide a method for traveling a requested distance (cumulative metric) from a specified starting element.

hints:

since the metrics for each element don't necessarily have the same sign, the direction of travel to reach the requested distance may be the apparently opposite direction.

the distance around one cycle may or may not be zero.

there may be no exact match for the request, or multiple matches.  how can you detect this condition?

how can the algorithm be optimized (eg for large requested distances)?

what would be the geometric interpretation of relaxing the property that the distance from an element to other instances of itself are multiples of the sum of the metrics?
-}

-- |extend 'Cyc' to a nonuniform metric (default is unity)
--
-- this could be generalized in at least two ways -- allow ascending and descending metric to differ, and allow the end of the loop to not match up with the beginning (loopMetric not equal to sum of metrics), creating phasing (destroying octave equivalence).  currently punting on these, but may be worth exploring for interesting effects.
--
--  no minimum definition (completely derivable -- but haskell can't autoderive custom classes?)
--
--  metric must be Real rather than Num cuz we need toRational to be able to divide a requested metric by loopMetric so we can shortcut search (tho i think you can divide complex numbers)
--  and we need Ord so we can compare metrics
--
--  we subclass Cyc cuz we need travel and path.  these are not inherently cyclic, so we could and should decouple these.
class (Real r, Cyc a) => MetricCyc r a where

{-
    -- |distance and path from 2nd to 3rd arg (inclusive)
    metricDist :: Bool -- ^'True' for ascending, 'False' for descending
               -> a
               -> a
               -> (r, [a])
    -- any way to clean this up?
    metricDist True x y  = (sum $ metricLookup xs, xs ++ [y])
        where xs = takeWhile (/= y) $ pathFrom True x
    metricDist False x y = (-n, reverse xs)
        where (n, xs) = metricDist True y x
-}

    -- |metric for n steps
    metricDist :: Int
               -> a
               -> r
    -- shouldn't have both seekMetric and this calling metricLookup -- change this to work via seekMetric (refactor seekMetric to take out irrelevant parts for this kind of thing)
    metricDist n x = (*) (fromIntegral $ signum n) $ sum $ metricLookup $ f $ path n x -- pointfree this
        where f = if   n > 0
                  then init
                  else tail

{-
    -- |list of cumulative metrics from first to second num steps away
    metricPath :: Int
               -> Int
               -> a
               -> [(Int, a, r)]
    -- ugly!
    metricPath i j x = filter (\x -> between i j $ fst x) z
        where xs          = (if dir > 0 then init else tail) $ pathRange fixI fixJ x
              dir         = fromIntegral $ signum $ j - i
              (fixI,fixJ) = includeZero i j 0
              z           = zip3 [fixI..fixJ] xs $ map (* dir) $ cumsum $ metricLookup xs
-}
{-
    -- |shortest distance and path from 1st to 2nd arg (inclusive)
    metricPathFromTo :: a
                     -> a
                     -> (r, [a])
    -- notice down = -(signum up) * mod up loopMetric
    metricPathFromTo x y = best $ map (\b -> metricDist b x y) [True, False] -- how remove lambda, pointfree x and y?  i think Prelude.sequence and/or applicative functors will help here...
-}

    -- |distance of one ascending trip around the loop
    loopMetric :: a
               -> r
    -- lame that we need dummy arg -- would rather call like 'InstanceName.loopMetric' or something, but (metricOK, length, metric) block the compiler from inferring the type, and compiler requires that type mentions a
    loopMetric x = {-(metricOK x) `seq`-} metricDist (numElems x) (minBound `asTypeOf` x)

    -- |ascending metrics associated with the elements of the arg
    metricLookup :: [a]
                 -> [r]
    -- any way to clean this up?
    metricLookup xs@(x:_) = {-(metricOK x) `seq`-} cleanMaybes "unknown problem - got a Nothing and metric is OK..." ns
        where ns = index (metric x) $ maybeize (enumInds xs)
    metricLookup _        = []

{- ghc needs to know type of (metric x), and isn't happy with ((metrix x)::[r]) -- why is (metric x) ok above?  i think cuz r is not mentioned in type of metricOK...
    -- |error if 'metric' has fewer elements than 'Cyc' 'Enum', otherwise return 'True'
    --  we could 'cycle' the metric, but we leave that to the client to decide
    metricOK :: a
             -> Bool
    -- lame that we need dummy arg -- would rather call like 'InstanceName.metricOK' or something, but compiler requires that type mentions a and we need it for the other methods that need dummies
    metricOK x | atLeast (numElems x) (metric x) = True
               | otherwise                                         = error "metric has fewer values than the Cyc Enum"
-}

    -- |specifies the metric associated with ascending motion from each step
    --
    --  default is every step unity
    --
    --  BUG: how make static guarantee that the lengths match?
    metric :: a
           -> [r]
    -- lame that we need dummy arg -- would rather call like 'InstanceName.metric' or something, but compiler requires that type mentions a
    metric x = replicate (numElems x) 1

    -- |distance from 1st to 2nd arg, in direction that does not wrap
    metricDiff :: a
               -> a
               -> r
    metricDiff x y = metricDist (yi-xi) x
        where [xi, yi] = enumInds [x, y]

    -- |travel a requested amount of cumulative metric from a starting point (in fewest steps possible)
    metricTravel
        :: Integral b =>
           r     -- ^amount of metric to travel
        -> a     -- ^starting point
        -> Maybe (b,a) -- ^'Nothing' if no exact match
        {-
            ( b  -- ^number complete loops
            , a  -- ^final point
            )
        -}

    metricTravel dist start =
        if   null paths
        then Nothing
        else Just (fixLoops , final)
        where paths                 = metricPaths dist start
              (loops, steps, final) = minimumBy (compare `on` (\(f,s,_) -> abs $ totalSteps f s)) paths -- minimumBy makes this strict, so not as efficient as searching out incrementally in both directions (as in previous solution) -- try to get back to that design...
              totalSteps f s        = f * n + s
              fixLoops              = truncate $ ((/) `on` toRational) (totalSteps loops steps) n
              n                     = numElems start

    -- |predicate for points in same metric locus (first arg is a dummy i think we can get rid of with type classes)
    isarithmic
        :: r
        -> a
        -> a
        -> Bool
    --how do this without a dummy to get the metric type?
    isarithmic t x y =
        x `elem` (isarithm (0 `asTypeOf` t) y)

    -- |locus of points at requested metric from starting point
    isarithm
        :: r
        -> a
        -> [a]
    isarithm m x =
        nub $ map (\(_,_,z) -> z) $ metricPaths m x -- pointfree this

    -- |find all items that are the requested cumulative metric from a starting point
    metricPaths
        :: r
        -> a
        -> [(Int,Int,a)]
        {- [( Int -- ^num loops
              Int -- ^num steps
            , a   -- ^matching item
           )]
        -}
    metricPaths m x =
        foldr (\(_,_,steps,met,item,_) -> if met == leftover then ((numLoops,steps,item) :) else id) [] (concat $ map ms [True,False])
        where op       = if   0 == slope -- need to set types here?  compiler says d not used...  a bit dangerous with floats in any case...
                         then take d
                         else takeWhile (\(_,_,_,_,_,lx) -> lx < d)
              d        = numElems x
              ms b     = op $ iterate seekMetric (leftover,b,0,0,x,0)
              slope    = (loopMetric x) `asTypeOf` m
              numLoops = if slope == 0 then 0 else truncate (((/) `on` toRational) m slope)
              leftover = m - ((fromIntegral numLoops) * slope)

    -- |accumulator method for cumulative metric seeking
    seekMetric
        :: (r,Bool,Int,r,a,Int) -> (r,Bool,Int,r,a,Int)
        {-
         (   r    -- ^target cumulative metric
           , Bool -- ^direction ('True' for ascending, 'False' for descending)
           , Int  -- ^last step number
           , r    -- ^last cumulative metric
           , a    -- ^last item
           , Int  -- ^steps since cumulative metric crossed target
           )
        -> (      -- ^last four values updated
             r
           , Bool
           , Int
           , r
           , a
           , Int
           )
        -}
    seekMetric (targ, dir, lastStep, lastM, lastItem, lastLastXing) =
        (targ, dir, newStep, newM, newItem, newLastXing)
        where op          = if dir then 1 else -1
              newM        = lastM + (fromIntegral op) * (head $ metricLookup [(if dir then lastItem else newItem)])
              newItem     = travel op lastItem
              newLastXing = if between lastM newM targ && (newM == targ || lastM /= targ) then 0 else lastLastXing + 1
              newStep     = lastStep + op
